home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 February: Tool Chest / Dev.CD Feb 95 / Dev.CD Feb 95.toast / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / Travers' lisp contrib.sea / Travers' lisp contrib / backup.lisp < prev    next >
Encoding:
Text File  |  1992-01-26  |  2.6 KB  |  61 lines  |  [TEXT/CCL2]
  1. ;;; Make backup versions of files
  2.  
  3. (defparameter *backup-files* t)
  4. (defparameter *too-many-versions* 6)
  5.  
  6. ;;; This makes a pseudo-versioned copy of a file.
  7. (defun backup-file (file &key (rename-old-file nil) (query-for-reap t))
  8.   (when (probe-file file)               ; if file doesn't exist yet, nothing happens
  9.     (let* ((all-files (directory (version-n-pathname file "*"))))
  10.       ;; not efficient ... there should be a maximize function that takes a :key arg
  11.       (setq all-files (sort all-files #'> :key #'pathname-pseudoversion))
  12.       (let* ((max-pathname (car all-files))
  13.              (version (if max-pathname 
  14.                         (1+ (pathname-pseudoversion max-pathname))
  15.                         1))
  16.              (backup-file (version-n-pathname file version)))
  17.         (if rename-old-file 
  18.           (rename-file file backup-file)
  19.           (copy-file file backup-file))
  20.         (at-listener-level
  21.           (when (and query-for-reap
  22.                      (> (length all-files) *too-many-versions*)
  23.                      (y-or-n-p "Delete excess backups of ~A?" file))
  24.             (clean-backups file)))
  25.         backup-file)))) 
  26.  
  27. (defun clean-backups (file &key (versions-to-keep 2) (verbose t))
  28.   (let* ((all-files (directory (version-n-pathname file "*"))))
  29.     (setq all-files (sort all-files #'> :key #'pathname-pseudoversion))
  30.     (dolist (file-to-delete (nthcdr (- versions-to-keep 1) all-files))
  31.       (when verbose (format t "~%Deleting ~A" file-to-delete))
  32.       (delete-file file-to-delete)
  33.       )))
  34.  
  35. ;;; these two functions define the backup pathnames (currently of the form "foo~23.lisp")
  36. (defun version-n-pathname (file version)
  37.   (make-pathname :name (format nil "~A~~~A" (pathname-name file) version)
  38.                  :defaults file))
  39.  
  40. (defun pathname-pseudoversion (pathname)
  41.   (let* ((string (namestring pathname))
  42.          (number-start (1+ (position #\~ string :from-end t)))
  43.          (number-end (position nil string :start number-start
  44.                                :test-not #'(lambda (y x)
  45.                                              (declare (ignore y))
  46.                                              (char<= #\0 x #\9)))))
  47.     (read-from-string string nil 0 :start number-start :end number-end)))
  48.  
  49. ;;; this is risky because the system may define it's own :before method someday
  50. (defmethod window-save :before ((w window))
  51.   (when *backup-files*
  52.     (window-backup w)))
  53.  
  54. (defmethod window-backup ((w window))
  55.   (warn "I don't know how to backup windows of class ~A, perhaps you 
  56. would like to write some code!" (class-name (class-of w))))
  57.  
  58. (defmethod window-backup ((w fred-mixin))
  59.   (let ((file (ccl::stream-filename w)))
  60.     (when file (backup-file file))))
  61.